Shareware Grab Bag/Shareware Grab Bag.iso/050/madtrb17.arc/LSPELL.PAS

Pascal/Delphi Source File | 1985-12-29 | 25KB | 940 lines

{
    An experimental Turbo Lightning-based document speller.

    This program is hereby placed in the public domain.  You may copy it,
    modify it, and use it; you may NOT sell it or in any other way attempt
    to make money from it.

    The author assumes no liability for any damage of any kind resulting
    from use of this program.  All risk of use is on the user.  You are
    warned that this program is experimental.

    Christopher J. Dunford
    The Cove Software Group
    10057-2 Windstream Drive
    Columbia, Maryland 21044

    CompuServe 76703,2002

    12/28/85

    Turbo Lightning is a trademark of Borland International, Inc.
}

Program Spell;

Const
    Dummy: String[10] = '         ';
    MaxLearn = 200;                       { Max # Learn table entries }

Type
    Str66 = String[66];
    Str128 = String[128];
    Str255 = String [255];
    S255Ptr = ^Str255;

    CharSet = Set of Char;

    TLPtrType = ^TLtype;

    TLtype = record
        Rsrv1,                           { RSRVx is stuff we don't use }
        Rsrv2: Integer;
        Rsrv3,
        Rsrv4,
        Rsrv5: Array [0..2] of byte;
        Rsrv6,
        Rsrv7,
        Rsrv8,
        Rsrv9,
        Rsrv10,
        Rsrv11,
        Rsrv12,
        Rsrv13,
        Rsrv14,
        Rsrv15,
        Rsrv16,
        AuxFileOfs,             { Auxi Dict filename offset }
        Rsrv17,
        Rsrv18,
        Rsrv19,
        SubstList,              { Offset of substitute word list }
        Rsrv20,
        Rsrv21,
        Rsrv22,
        Rsrv23: Integer;
    End;

Var
    f,                      { Input file }
    g: file of byte;        { Output file }
    AuxName: Str66;         { Name of auxiliary dictionary file }
    infile,                 { Name of input file }
    bakfile: Str128;        { Derived name of backup file }

    TLPtr: TLPtrType;       { Ptr to Lightning's info structure }

    SkipWord,               { TRUE if user selected SKIP for current word }
    Abort,                  { Cancel flag }
    SaveAutoProof:          { User's autoproof status }
            Boolean;

    WordCount,              { Word count }
    InPtr,                  { Pointer to next char of input }
    wstart,                 { Ptr to start of current word in input }
    wlen,                   { Length of current word }
    InLen,                  { Length of current input line }
    Terminator,             { Char which terminated current input line }
    LearnCount:             { Number of entried is Learn table }
            Integer;

    LearnList:              { Table of Learn words }
            Array[1..MaxLearn] Of String[32];

    w,                      { Word currently being checked }
    InStr,                  { Current input line }
    OutStr:                 { Current output line }
            Str255;

    ch: char;               { A junk character }


Function Lightning(fcode,
                   alvalue,
                   cxvalue,
                   dxvalue: Integer;
                   var AnyString): Integer;

{  This function calls Lightning and returns a status code  }

Type CPU = record case integer of
            1: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Integer);
            2: (AL, AH, BL, BH, CL, CH, DL, DH: Byte);
    End;

Var
    R: CPU;

Begin
    R.al := Lo (alvalue);
    R.ah := $ed;
    R.bh := $ed;
    R.bl := Lo (fcode);
    R.cx := cxvalue;
    R.dx := dxvalue;
    R.ds := seg (AnyString);
    R.si := ofs (AnyString);
    intr ($16,R);
    Lightning := R.ax
End;


Function AutoProof(On: boolean): boolean;
{  Set/reset AutoProof mode and return the previous state. }
Var
    NewState: integer;
Begin
    If On Then
        NewState := $FF
    Else
        NewState := 0;
    AutoProof := (Lightning(6, NewState, 0, 0, Dummy) <> 0)
End;


Function TLAddress: TLPtrType;
{
    Return a pointer to Lightning's internal data structure.
    This structure is represented here by the TLtype.
}
Begin
    TLAddress := Ptr(Lightning(2, 0, 0, 0, Dummy), Lightning(3, 0, 0, 0, Dummy));
End;


Function  LightningPresent : Boolean;
{ Return TRUE if Lightning is active }
Begin
    LightningPresent := (Lightning (0, 0, 0, 0, Dummy) = $5205)
End;


Function GetNumSubst: integer;
{
    Return number of words that are likely substitutes for
    the last word that was checked.  The words themselves are
    in a list of strings; the address of this list is obtained
    by getting a pointer to the TL record (by calling function
    TLAddress).  The segment of the list is the same as the
    TL record's segment, and the offset is contained in the
    record itself (field LikeyWordOfs).

    The list is a series of strings, each with a leading length byte.
}
Begin GetNumSubst := Lightning ($F, 0, 0, 0, Dummy) End;


Procedure MakeAuxDictName;
{
    Access Lightning's data structure to access the current
    Auxiliary dictionary's filename.   Assign the name to the
    variable AuxName.
}
Var
    AuxNamePtr: Record Case Boolean Of
                    True:  (c: ^char);
                    False: (O : integer;
                            S : integer;);
                End;
    i: Integer;

Begin
    AuxNamePtr.S := Seg(TLPtr^);
    AuxNamePtr.O := TLPtr^.AuxFileOfs;
    i := 0;
    While AuxNamePtr.c^ <> #0 Do Begin
        i := Succ(i);
        AuxName [i] := AuxNamePtr.c^;
        AuxNamePtr.O := Succ(AuxNamePtr.O)
    End;

    AuxName [0] := char(i);
    While (i > 0) And (AuxName[i] <> '\') And (AuxName[i] <> '.') Do
        i := Pred(i);
    If (i = 0) Or ((i > 0) And (AuxName[i] = '\')) Then
        AuxName := AuxName + '.DIC'
End;


Function LoadAuxDict: boolean;
{
    Force Lightning to load the auxiliary dictionary; return TRUE
    if OK.  Note that it appears necessary to force a reload after
    each word is added to the Auxi dic.
}
Begin
    LoadAuxDict := (Lightning (4, 0, 0, 0, AuxName) = 0)
End;


Procedure Wait;
{ Display message and wait for a keystroke }
Var ch: char;
Begin
     Write ('Strike any key to continue...');
     Read (kbd, ch)
End;


Function tolower(ch:char): char;
{ Lowercase a character }
Begin
    If (ch In ['A'..'Z'])
        Then tolower := chr(ord(ch) + 32)
        Else tolower := ch
End;


Function toupper(ch:char): char;
{ Uppercase a character }
Begin
    If (ch In ['a'..'z'])
        Then toupper := chr(ord(ch) - 32)
        Else toupper := ch
End;


Function HasDigit: Boolean;
{ Return TRUE if the word 'w' contains a digit }
Var
    i: Integer;
    Digit: Boolean;
Begin
    i := 1;  Digit := False;
    While (i <= wlen) And Not Digit Do Begin
        Digit := (w[i] In ['0'..'9']);
        i := i+1
    End;
    HasDigit := Digit
End;


Procedure ReadLine;
{
    Read next line from input file.  Can't use simple ReadLn
    because the input may be a word processor document, potentially
    containing any number of weird characters (including x'00'
    and ^Z, incidentally) and may not be terminated by a standard
    CRLF pair.  We'll consider the line to be terminated by any
    of the various CR/LF's.  The actual terminator will be placed
    in the global var 'Terminator'; if there is no terminator (i.e.,
    file read to EOF without a line end, Terminator will be set to -1.
    On exit, the input line will be in the global var 'InStr', and its
    length in 'InLen'.
}
Var
    EOL: Boolean;
    ch: Char;
    q: byte;

Begin
    InStr := '';
    EOL := False;
    InLen := 0;
    Terminator := -1;

    While (InLen < 255) And Not Abort And Not EOL And Not EOF(f) Do Begin
        {$i-} Read (f, q); {$i+}
        If IOResult <> 0 Then Begin
            ClrScr;
            Gotoxy (1,10);
            WriteLn ('Error reading input file...cancelling...');
            Abort := TRUE;
        End Else Begin
            ch := chr(q);
            EOL := ch In [chr($0D), chr($0A), chr($8D), chr($8A)];
            If Not EOL Then Begin
                InLen := InLen+1;
                InStr[InLen] := ch
            End Else
                Terminator := ord(ch)
        End
    End;

    InStr[0] := chr(InLen)
End;



Procedure GetWord;
{
    Get the next "word" from the input stream and places
    it in the global variable 'w'. Adds all leading separators
    to 'OutStr'.  On exit, 'wstart' points to the start of
    the word in InStr, and 'wlen' is the word's length.
}

Var
    OutLen: Integer;
    Alphameric: Boolean;

Begin
    wlen := 0;

    { Scan off leading non-alphanumerics }
    OutLen := Length (OutStr);
    Alphameric := False;
    While Not Alphameric Do Begin
        If InPtr > InLen Then
            Alphameric := True
        Else Begin
            ch := InStr[InPtr];
            Alphameric := (ch In ['a'..'z', 'A'..'Z', '0'..'9']);
            If Not Alphameric Then Begin
                OutLen := OutLen + 1;
                OutStr[OutLen] := ch;
                InPtr := InPtr+1
            End
        End
    End;
    OutStr[0] := chr(OutLen);

    { Get word...until next non-alphanumeric }
    If InPtr <= InLen Then Begin
        wstart := InPtr;
        While AlphaMeric Do Begin
            If InPtr > InLen Then
                Alphameric := False
            Else Begin
                ch := InStr[InPtr];
                Alphameric := (ch In ['a'..'z', 'A'..'Z', '0'..'9', '''']);
                If Alphameric Then Begin
                    wlen := wlen + 1;
                    w[wlen] := ch;
                    InPtr := InPtr+1
                End
            End
        End
    End;

    w[0] := chr(wlen);
    If wlen <> 0 Then WordCount := WordCount + 1
End;


Procedure WriteLine;
{
    Write the line 'OutStr' to the output file.  Write the
    'Terminator' character if it is not -1.
}
Var
    i: Integer;
    ch: Char;
    q: Byte;

        Function CheckIO: Boolean;
        Begin
            If IOResult <> 0 Then Begin
                ClrScr; Gotoxy (1,10);
                WriteLn ('Error writing output file...cancelling...');
                Abort := True;
                CheckIO := TRUE
            End Else
                CheckIO := FALSE
        End;

Begin
    For i := 1 To Length(OutStr) Do Begin
        q := byte(OutStr[i]);
        {$i-} Write (g, q); {$i+}
        If CheckIO Then Exit;
    End;

    If Terminator <> -1 Then Begin
        q := byte (Terminator);
        {$i-} Write (g, q); {$i+}
        If CheckIO Then Exit;
    End
End;



Function WordInDict: Boolean;
{
    Look up the word 'w'.  Word is considered found (return value TRUE) if:
        1.  w is a null string.
        2.  w contains any digits
        3.  w is in the list of Learn words.
        4.  (Failing the above) Lightning can find the word.

    If the word is not found but is terminated with <'> or <'s> or
    <'S>, then delete the possessive and look it up again.

    Note that Lightning checks the RAM dict, the Auxi dict, and the
    disk dict in that order.

}
Var
    Found: Boolean;
    APos, k: Integer;

        Function Lookup (wd: Str255): Boolean;
        { Return TRUE if the word 'wd' is OK }
        Var
            Found: Boolean;
            i: Integer;
        Begin
            If wd = '' Then
                Found := True
            Else If HasDigit Then
                Found := True
            Else Begin
                i := 1;  Found := False;
                While (i <= LearnCount) And Not Found Do Begin
                    Found := (wd = LearnList[i]);
                    i := i+1
                End;

                If Not Found Then
                    If (Lightning ($E, 0, 0, 0, wd) <> 1)
                        Then Found := true
                        Else Found := (Lightning (1, 0, 0, 0, wd) = 0)
            End;
            Lookup := Found
        End;

Begin  { WordInDict }
    Found := Lookup (w);
    If Not Found Then Begin { Check for possessives }
        APos := Pos('''', w);
        If Apos <> 0 Then Begin
            k := Length (w);
            If (APos = k) Or ((Apos = k-1) And (toupper (w[k]) = 'S'))
                Then Found := Lookup (Copy (w, 1, APos-1))
        End
    End;
    WordInDict := Found
End;


Procedure Phonetic;
{
    Drives the Phonetic (lookup) option.  Looks up possible
    words, displays them, and gets a selection.  The selected
    word is return in global var 'w'; if no selection is made,
    'w' is unchanged.
}
Var
    NumSubst, len, i, k, x, y: Integer;
    Column, Columns, width, Long: Integer;
    OK: Boolean;
    ch: Char;
    SubstPtr: Record Case Boolean Of
                True:  (SP: S255Ptr);
                False: (O: Integer;
                        S: Integer;);
            End;
    s: Str255;

Begin
    NumSubst := GetNumSubst; { Number of soundalike words }

    If NumSubst = 0 Then Begin
        Write ('No phonetics found...strike any key...');
        Read (kbd, ch);
    End Else Begin
        { Find longest likely }
        SubstPtr.S := Seg(TLPtr^);
        SubstPtr.O := TLPtr^.SubstList;
        Long := 0;
        For i := 1 To NumSubst Do Begin
            Len := byte(SubstPtr.SP^[0]);
            If len > Long Then Long := Len;
            SubstPtr.O := SubstPtr.O + Len + 1;
        End;

        { Calculate width, and number per line }
        Long := Long + 6;
        Columns := 79 DIV (Long);
        Width := 79 DIV Columns;

        { Display word list }
        Gotoxy (1,5);  ClrEOL;
        Column := 0;

        SubstPtr.S := Seg(TLPtr^);
        SubstPtr.O := TLPtr^.SubstList;

        For i := 1 To NumSubst Do Begin
            len := byte(SubstPtr.SP^[0]);
            s[0] := char(len);
            move (SubstPtr.SP^[1], s[1], len);
            Gotoxy (Column * width, WhereY);
            If Column = 0 Then ClrEOL;
            Write (i:2, ': ', s);
            Column := Column + 1;
            If Column = Columns Then Begin
                WriteLn;
                Column := 0;
            End;
            SubstPtr.O := SubstPtr.O + len + 1;
        End;

        { Get selection }
        WriteLn;
        x := WhereX; y := WhereY;
        Repeat
            Gotoxy (x, y);  ClrEol;
            Write ('Select number, or <Return>: ');
            ReadLn (s);
            If s = '' Then
                OK := True
            Else If length(s) > 3 Then
                OK := False
            Else Begin
                k := 0;
                OK := True;
                For i := 1 To Length(s) Do
                    If (s[i] In ['0'..'9'])
                        Then k := 10*k + ord(s[i]) - ord('0')
                        Else OK := False;
                If OK Then OK := (k > 0) And (k <= NumSubst)
            End
        Until OK;

        { Get the selected word from the Lightning list }
        If s <> '' Then Begin
            SubstPtr.S := Seg(TLPtr^);
            SubstPtr.O := TLPtr^.SubstList;
            s[0] := char(36);

            For i := 1 To k-1 Do
                SubstPtr.O := SubstPtr.O +
                             Succ(byte(SubstPtr.SP^[0]));
            move (SubstPtr.SP^[1], s[1], byte(SubstPtr.SP^[0]));
            s[0] := char(36);
            w := copy(s, 1, byte(SubstPtr.SP^[0]))
        End
    End
End;


Procedure AddToAuxi;
{
    Add the word 'w' to the current auxiliary dictionary.  The Auxi
    dict is just an ASCII text file contain a list of words, one
    per line.  This procedure includes the option list for capitalization.
}
Var
    Auxi: Text;
    i, IOError: Integer;
    dummy: Boolean;
    Option: Char;
    w1: Str255;


    Function AddMenu: Char;
    { Return a selection from the ADD Option menu }
    Var ch: Char;
    Begin
        Write ('Add option: A(s shown  U(ppercase  L(owercase  I(nitial  <Esc> ');
        Repeat
            Read (kbd, ch);
            ch := toupper (ch);
        Until (ch In ['A', 'U', 'L', 'I', chr(27)]);
        AddMenu := ch
    End;


    Function CheckIO: Boolean;
    {
        If current IOResult is nonzero, display a message and close
        the Auxi file.  Return TRUE if there was an error.
    }
    Begin
        If IOResult <> 0 Then Begin
            WriteLn;
            WriteLn ('Error updating aux dict file ', AuxName);
            Wait;
            close (Auxi);
            CheckIO := TRUE
        End Else
            CheckIO := FALSE
    End;

Begin { AddToAuxi }
    Option := AddMenu;
    Gotoxy (1, WhereY); ClrEOL;
    If Option <> chr(27) Then Begin
        w1 := w;
        Case Option Of { Handle the capitalization option }
        'U': For i := 1 To Length (w1) Do w1[i] := toupper (w1[i]);
        'L': For i := 1 To Length (w1) Do w1[i] := tolower (w1[i]);
        'I': Begin
                w1[1] := toupper (w1[1]);
                For i := 2 To Length(w1) Do w1[i] := tolower (w1[i])
             End
        End;

        {$i-}
        Repeat
            If AuxName = '' Then
                IOError := -1
            Else Begin
                Assign (Auxi, AuxName);
                IOError := IOResult;
            End;

            If IOError = 0 Then Begin
                Append (Auxi);
                IOError := IOResult;
            End;

            If IOError <> 0 Then Begin
                ClrScr;  Gotoxy (1,10);
                WriteLn ('Unable to open auxiliary dictionary file ', AuxName);
                Write ('Enter new aux dict name, or <Return> for none: ');
                ReadLn (AuxName);
                Gotoxy (1,10); ClrEOL;
                Gotoxy (1,11); ClrEOL;
                If AuxName = '' Then Exit;
            End;
        Until IOError = 0;

        Writeln (Auxi, w1);
        If CheckIO Then Exit;

        Write (Auxi, chr(26));
        If CheckIO Then Exit;

        Close (Auxi);
        {$i+}

        SkipWord := True;     { In case capitalization in Auxi is different }
        dummy := LoadAuxDict  { Force reload }
    End
End;



Procedure CorrectError;
{
    Drives the stuff that happens when a word isn't found:
        Display the misspelled word in context.
        Get a correction option selection.
        Case Option of
            Edit:     get a new word from keyboard
            Skip:     set SkipWord to TRUE
            Learn:    add word to Learn list
            Phonetic: perform Phonetic procedure
            Add:      perform AddToAuxi procedure
            Cancel:   set Abort to TRUE

    On exit, the corrected word is in global var 'w'.  THIS WORD
    SHOULD BE RECHECKED!!!  I.e., for each word 'w', the checker
    should loop until:
        1. Abort is TRUE, or
        2. Skip is TRUE, or
        3. word is verified by the WordInDict procedure
}

    Procedure HiliteWord;
    {
        Display the misspelled word 'w' in context at top of screen.
    }
    Begin
        ClrScr; Gotoxy (1,2);
        Write (OutStr);

        TextColor (0); TextBackground (7);
        Write (w);
        TextColor (7); TextBackground (0);

        If InPtr <= InLen Then
            Write (Copy (InStr, Inptr, Length(InStr)-Inptr));

        WriteLn;
    End;


    Function OptionMenu: Char;
    { Get the user option from the misspelled word menu }
    Var
        i: Integer;
        ch: Char;
    Begin
        Gotoxy (1, 4);
        For i := 1 To 80 Do Write ('-'); WriteLn;

        Gotoxy (1, 6);
        Write ('Select: S(kip  L(earn  E(dit  P(honetic  A(dd to dict  C(ancel ');

        Repeat
            Read (kbd, ch);
            ch := toupper (ch)
        Until (ch In ['S', 'L', 'E', 'P', 'A', 'C']);
        WriteLn (ch);
        OptionMenu := ch
    End;


    Procedure EditWord;
    { Get a replacement word from keyboard and put it in 'w' }
    Begin
        WriteLn;
        Write ('Enter correction, or <Return> to delete word: ');
        ReadLn (w)
    End;


    Procedure AddToLearns;
    { Add word 'w' to the Learn word list }
    Begin
        If LearnCount < MaxLearn Then Begin
            LearnCount := LearnCount + 1;
            LearnList[LearnCount] := w
        End
    End;

Begin { CorrectError }
    HiliteWord;
    Case OptionMenu Of
         'S': SkipWord := True;
         'L': AddToLearns;
         'E': EditWord;
         'P': Phonetic;
         'A': AddToAuxi;
         'C': Abort := TRUE
     End;
     Gotoxy (1,1); ClrEOL;
End;



Procedure Init;
{
    Program initialization
}


    Procedure Logo;
    Begin
        WriteLn ('lspell 0.93 Copyright (c) 1985 Cove Software Group');
    End;


    Procedure Usage;
    Begin
        Logo;
        WriteLn ('usage:- lspell filename');
        Halt;
    End;


    Function Exist (s: Str128): Boolean;
    { Returns TRUE if file 's' exists }
    Var f: File;
    Begin
        {$i-}
        Assign (f, s);
        Reset (f);
        Exist := (IOResult = 0);
        Close (f);
        {$i-}
    End;


Begin { Init }
    { Get rid of Turbo's stupid hi-intensity video }
    TextColor (7);  TextBackground (0);

    { Ensure Lightning is running }
    If Not LightningPresent Then Begin
        Logo;
        WriteLn ('lspell: Turbo Lightning (tm) not present');
        Halt;
    End;

    { Make sure we got right # of parms }
    If ParamCount <> 1 Then Usage;

    { Derive the backup file name }
    infile := ParamStr (1);
    If pos('.', infile) > 0 Then Begin
        bakfile := copy(infile, 1, pos('.', infile)-1);
        bakfile := concat (bakfile, '.@ls');
    End Else
        bakfile := concat (infile, '.@ls');

    { Make sure we haven't been asked to spell a .@ls file }
    If infile = bakfile Then Begin
        Logo;
        WriteLn ('lspell: can''t spellcheck a .@ls file');
        Halt;
    End;

    { Check for input file existence }
    If Not exist (infile) Then Begin
        WriteLn ('lspell: can''t find input file ', infile);
        Halt
    End;

    {$i-}

    { Erase old .@ls file }
    If Exist(bakfile) Then Begin
        Assign (f, bakfile);
        Erase (f);
    End;

    { Rename the input file to .@ls }
    Assign (f, infile);
    Rename (f, bakfile);

    { Open input (now .@ls) }
    Assign (f, bakfile);
    reset (f);
    If IOResult <> 0 Then Begin
        Logo;
        WriteLn ('lspell: can''t find input file', infile);
        Halt;
    End;

    { Create output file (using original filename) }
    Assign (g, infile);
    Rewrite (g);
    If IOResult <> 0 Then Begin
        Logo;
        WriteLn ('lspell: error opening output file');
        Halt;
    End;
    {$i+}

    { Set up the pointer to the Lightning info structure }
    TLPtr := TLAddress;

    { Get the name of the auxiliary dictionary, and load it }
    MakeAuxDictName;
    If Not LoadAuxDict Then Begin
        Logo;
        WriteLn ('Warning: auxiliary dictionary ', AuxName, ' not found');
        Wait
    End;

    { Turn off autoproof and save user's status }
    SaveAutoProof := AutoProof(False);

    { Initialize a couple of variables and prepare the screen }
    Abort := FALSE;
    LearnCount := 0;
    WordCount := 0;
    ClrScr;
    Gotoxy (1,2)
End; { Init }


Procedure CheckSpelling;
{
    Main spelling loop.  Reads input line-by-line, gets
    words and checks them, and writes output.
}
Begin
    While Not Abort And Not EOF(f) Do Begin
        ReadLine;
        If Not Abort Then Begin
            Gotoxy (1,2);  ClrEOL;  Write (Copy (InStr, 1, 79));
            OutStr := '';

            InPtr := 1;
            While InPtr <= InLen Do Begin
                GetWord;
                SkipWord := False;
                While Not Abort And Not SkipWord And Not WordInDict Do
                    CorrectError;
                OutStr := concat (OutStr, w)
            End;

            WriteLine
        End
    End
End;


Procedure Terminate;
{
    Termination.  Fix up the files, and restore autoproof.
}
Var
    dummy: Boolean;
Begin
    Close (f);
    Close (g);

    ClrScr;

    { If program aborted, get rid of the partial output file
      and rename the backup file to its old name
    }
    If Abort Then Begin
        {$i-}
        Assign (f, infile);  { Erase the aborted output file }
        Erase (f);
        Assign (f, bakfile); { Restore .@ls to original name }
        Rename (f, infile)
        {$i+}
    End Else Begin
        Gotoxy (1,10);
        Write ('Spelling complete: ', WordCount, ' words')
    End;

    { Restore user's autoproof status }
    dummy := AutoProof(SaveAutoProof)
End;


Begin { Spell }
    Init;
    CheckSpelling;
    Terminate
End.